home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / FORMAT.LSP < prev    next >
Text File  |  1994-02-05  |  78KB  |  1,803 lines
  1. ; FORMAT - und was dazugehört.
  2. ; Bruno Haible 22.06.1988
  3. ; CLISP-Version 16.08.1988, 03.09.1988, 04.08.1989
  4. ; Groß umgearbeitet von Bruno Haible am 14.02.1990-15.02.1990
  5.  
  6. (in-package "SYSTEM")
  7.  
  8. ;-------------------------------------------------------------------------------
  9.  
  10. ; Datenstruktur der Kontrollstring-Direktive:
  11. (defstruct (control-string-directive
  12.              (:copier nil)
  13.              (:conc-name "CSD-")
  14.              (:predicate nil)
  15.              (:constructor make-csd ())
  16.            )
  17.   (type         0 :type fixnum)
  18.   (cs-index     0 :type fixnum)
  19.   (parm-list    nil :type list)
  20.   (v-or-#-p     nil :type symbol)
  21.   (colon-p      nil :type symbol)
  22.   (atsign-p     nil :type symbol)
  23.   (data         nil)
  24.   (clause-chain nil)
  25. )
  26. #+CLISP (remprop 'control-string-directive 'sys::defstruct-description)
  27. ; Erläuterung:
  28. ; type=0 : Direktive ~<Newline>, nichts auszugeben.
  29. ;          Weitere Komponenten bedeutungslos
  30. ; type=1 : String auszugeben,
  31. ;          von *FORMAT-CS* die Portion :START cs-index :END data.
  32. ;          Weitere Komponenten bedeutungslos
  33. ; type=2 : Formatier-Direktive auszuführen.
  34. ;          data = Name der Direktive (Symbol),
  35. ;          colon-p gibt an, ob ein ':' da war,
  36. ;          atsign-p gibt an, ob ein '@' da war,
  37. ;          parm-list = Parameterliste an die Direktive,
  38. ;          v-or-#-p gibt an, ob parm-list vor dem Aufruf noch zu behandeln ist.
  39. ;          clause-chain ist eine Verzeigerung: z.B. bei ~[...~;...~;...~]
  40. ;          von der ~[-Direktive auf die Liste ab der ersten ~;-Direktive,
  41. ;          von da auf die Liste ab der nächsten ~;-Direktive usw.
  42. ;          bis schließlich auf die Liste ab der ~]-Direktive.
  43.  
  44. ; Zeigt an, ob ein Character ein Whitespace-Character ist.
  45. (defun whitespacep (char)
  46.   (member char '(#\Space #\Newline #\Linefeed #\Tab #\Return #\Page))
  47. )
  48.  
  49. ; (FORMAT-PARSE-CS control-string startindex csdl stop-at)
  50. ; parst einen Kontrollstring (genauer: (subseq control-string startindex))
  51. ; und legt die sich ergebende Control-String-Directive-Liste in (cdr csdl) ab.
  52. ; Das Parsen muß mit der Direktive stop-at enden (ein Character, oder NIL
  53. ; für Stringende).
  54. ; Falls stop-at /= NIL, ist in (csd-clause-chain (car csdl)) ein Pointer auf
  55. ; die Teilliste ab dem nächsten Separator einzutragen. Diese Pointer bilden
  56. ; eine einfach verkettete Liste innerhalb csdl: von einem Separator zum
  57. ; nächsten, zum Schluß zum Ende der Clause.
  58. (defun format-parse-cs (control-string startindex csdl stop-at)
  59.   (declare (fixnum startindex))
  60.   (macrolet ((errorstring ()
  61.                #+DEUTSCH "Kontrollstring endet mitten in einer Direktive."
  62.                #+ENGLISH "The control string terminates within a directive."
  63.                #+FRANCAIS "La chaîne de contrôle se termine en plein milieu d'une directive."
  64.             ))
  65.     (prog* ((index startindex) ; cs-index des nächsten Zeichens
  66.             ch ; current character
  67.             intparam ; Integer-Parameter
  68.             newcsd ; aktuelle CSD
  69.             (last-separator-csd (car csdl))
  70.            )
  71.       (declare (type simple-string control-string) (type fixnum index))
  72.       (loop ; neue Direktive insgesamt
  73.         (tagbody
  74.           (when (>= index (length control-string))
  75.             (go string-ended)
  76.           )
  77.           (setq ch (schar control-string index))
  78.           (unless (eql ch #\~)
  79.             ; eventuell noch Stringstück zu einer eingenen Direktive machen
  80.             (setq csdl (setf (cdr csdl) (list (setq newcsd (MAKE-CSD)))))
  81.             (setf (csd-type     newcsd) 1)
  82.             (setf (csd-cs-index newcsd) index)
  83.             (setq index (position #\~ control-string :start index))
  84.             (unless index
  85.               (setf (csd-data newcsd) (setq index (length control-string)))
  86.               (go string-ended)
  87.             )
  88.             (setf (csd-data newcsd) index)
  89.           )
  90.           (setq csdl (setf (cdr csdl) (list (setq newcsd (MAKE-CSD)))))
  91.           (setf (csd-type         newcsd) 2)
  92.           (setf (csd-cs-index     newcsd) index)
  93.           (setf (csd-parm-list    newcsd) nil)
  94.           (setf (csd-v-or-#-p     newcsd) nil)
  95.           (setf (csd-colon-p      newcsd) nil)
  96.           (setf (csd-atsign-p     newcsd) nil)
  97.           (setf (csd-data         newcsd) nil)
  98.           (setf (csd-clause-chain newcsd) nil)
  99.  
  100.           param ; Parameter einer Direktive kann beginnen
  101.           (incf index)
  102.           (when (>= index (length control-string))
  103.             (format-error control-string index (errorstring))
  104.             (go string-ended)
  105.           )
  106.           (setq ch (schar control-string index))
  107.           (when (digit-char-p ch) (go num-param))
  108.           (case ch
  109.             ((#\+ #\-) (go num-param))
  110.             (#\' (go quote-param))
  111.             ((#\V #\v #\#)
  112.              (push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG)
  113.                    (csd-parm-list newcsd)
  114.              )
  115.              (setf (csd-v-or-#-p newcsd) T)
  116.              (go param-ok-1)
  117.             )
  118.             (#\, (push nil (csd-parm-list newcsd)) (go param))
  119.             (#\: (go colon-modifier))
  120.             (#\@ (go atsign-modifier))
  121.             (T (go directive))
  122.           )
  123.  
  124.           num-param ; numerischer Parameter
  125.           (multiple-value-setq (intparam index)
  126.             (parse-integer control-string :start index :junk-allowed t)
  127.           )
  128.           (unless intparam
  129.             (format-error control-string index
  130.                           #+DEUTSCH "~A muß eine Zahl einleiten."
  131.                           #+ENGLISH "~A must introduce a number."
  132.                           #+FRANCAIS "~A doit introduire un nombre."
  133.                           ch
  134.           ) )
  135.           (push intparam (csd-parm-list newcsd))
  136.           (go param-ok-2)
  137.  
  138.           quote-param ; Quote-Parameter-Behandlung
  139.           (incf index)
  140.           (when (>= index (length control-string))
  141.             (format-error control-string index
  142.               #+DEUTSCH "Kontrollstring endet mitten in einem '-Parameter."
  143.               #+ENGLISH "The control string terminates in the middle of a parameter."
  144.               #+FRANCAIS "La chaîne de contrôle se termine au milieu d'un paramètre."
  145.             )
  146.             (go string-ended)
  147.           )
  148.           (setq ch (schar control-string index))
  149.           (push ch (csd-parm-list newcsd))
  150.  
  151.           param-ok-1 ; Parameter OK
  152.           (incf index)
  153.           param-ok-2 ; Parameter OK
  154.           (when (>= index (length control-string))
  155.             (format-error control-string index (errorstring))
  156.             (go string-ended)
  157.           )
  158.           (setq ch (schar control-string index))
  159.           (case ch
  160.             (#\, (go param))
  161.             (#\: (go colon-modifier))
  162.             (#\@ (go atsign-modifier))
  163.             (T (go directive))
  164.           )
  165.  
  166.           colon-modifier ; nach :
  167.           (setf (csd-colon-p newcsd) T)
  168.           (go passed-modifier)
  169.  
  170.           atsign-modifier ; nach @
  171.           (setf (csd-atsign-p newcsd) T)
  172.           (go passed-modifier)
  173.  
  174.           passed-modifier ; nach : oder @
  175.           (incf index)
  176.           (when (>= index (length control-string))
  177.             (format-error control-string index (errorstring))
  178.             (go string-ended)
  179.           )
  180.           (setq ch (schar control-string index))
  181.           (case ch
  182.             (#\: (go colon-modifier))
  183.             (#\@ (go atsign-modifier))
  184.             (T (go directive))
  185.           )
  186.  
  187.           directive ; Direktive (ihr Name) erreicht
  188.           (setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd)))
  189.           (let ((directive-name
  190.                   (cdr (assoc (char-upcase ch)
  191.                          '((#\A . FORMAT-ASCII)
  192.                            (#\S . FORMAT-S-EXPRESSION)
  193.                            (#\W . FORMAT-WRITE)
  194.                            (#\D . FORMAT-DECIMAL)
  195.                            (#\B . FORMAT-BINARY)
  196.                            (#\O . FORMAT-OCTAL)
  197.                            (#\X . FORMAT-HEXADECIMAL)
  198.                            (#\R . FORMAT-RADIX)
  199.                            (#\P . FORMAT-PLURAL)
  200.                            (#\C . FORMAT-CHARACTER)
  201.                            (#\F . FORMAT-FIXED-FLOAT)
  202.                            (#\E . FORMAT-EXPONENTIAL-FLOAT)
  203.                            (#\G . FORMAT-GENERAL-FLOAT)
  204.                            (#\$ . FORMAT-DOLLARS-FLOAT)
  205.                            (#\% . FORMAT-TERPRI)
  206.                            (#\& . FORMAT-FRESH-LINE)      (#\Newline . #\Newline)
  207.                            (#\| . FORMAT-PAGE)
  208.                            (#\~ . FORMAT-TILDE)
  209.                            (#\T . FORMAT-TABULATE)
  210.                            (#\* . FORMAT-GOTO)
  211.                            (#\? . FORMAT-INDIRECTION)
  212.                            (#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END)
  213.                            (#\[ . FORMAT-CONDITIONAL)     (#\] . FORMAT-CONDITIONAL-END)
  214.                            (#\{ . FORMAT-ITERATION)       (#\} . FORMAT-ITERATION-END)
  215.                            (#\< . FORMAT-JUSTIFICATION)   (#\> . FORMAT-JUSTIFICATION-END)
  216.                            (#\^ . FORMAT-UP-AND-OUT)      (#\; . FORMAT-SEPARATOR)
  217.                            ; mit Funktionsdefinition      ; ohne Funktionsdefinition
  218.                )) )    )  )
  219.             (if directive-name
  220.               (setf (csd-data newcsd) directive-name)
  221.               (format-error control-string index
  222.                 #+DEUTSCH "Diese Direktive gibt es nicht."
  223.                 #+ENGLISH "Non-existent directive"
  224.                 #+FRANCAIS "Directive non reconnue."
  225.           ) ) )
  226.           (incf index)
  227.           (case ch
  228.             (( #\( #\[ #\{ #\< )
  229.              (multiple-value-setq (index csdl)
  230.                (format-parse-cs control-string index csdl
  231.                  (case ch (#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) )
  232.              ) )
  233.             )
  234.             (( #\) #\] #\} #\> )
  235.              (unless stop-at
  236.                (format-error control-string index
  237.                  #+DEUTSCH "Schließende Klammer '~A' ohne vorherige öffnende Klammer"
  238.                  #+ENGLISH "The closing directive '~A' does not have a corresponding opening one."
  239.                  #+FRANCAIS "Parenthèse fermante '~A' sans parenthèse ouvrante correspondante."
  240.                  ch
  241.              ) )
  242.              (unless (eql ch stop-at)
  243.                (format-error control-string index
  244.                  #+DEUTSCH "Schließende Klammer '~A' paßt nicht; sollte '~A' lauten."
  245.                  #+ENGLISH "The closing directive '~A' does not match the corresponding opening one. It should read '~A'."
  246.                  #+FRANCAIS "La parenthèse fermante '~A' ne correspond pas à celle ouvrante. Il devrait y avoir '~A'."
  247.                  ch stop-at
  248.              ) )
  249.              (setf (csd-clause-chain last-separator-csd) csdl)
  250.              (go end)
  251.             )
  252.             (#\;
  253.              (unless (or (eql stop-at #\]) (eql stop-at #\>))
  254.                (format-error control-string index
  255.                  #+DEUTSCH "Hier ist keine ~~;-Direktive möglich."
  256.                  #+ENGLISH "The ~~; directive is not allowed at this point."
  257.                  #+FRANCAIS "La directive ~~; n'est pas permise ici."
  258.              ) )
  259.              (setf (csd-clause-chain last-separator-csd) csdl)
  260.              (setq last-separator-csd newcsd)
  261.             )
  262.             (#\Newline
  263.              (setf (csd-type newcsd) 0)
  264.              (if (csd-colon-p newcsd)
  265.                (if (csd-atsign-p newcsd)
  266.                  (format-error control-string index
  267.                    #+DEUTSCH "Die ~~Newline-Direktive ist mit : und @ sinnlos."
  268.                    #+ENGLISH "The ~~newline directive cannot take both modifiers."
  269.                    #+FRANCAIS "La directive ~~Newline est insensée avec les deux qualificateurs : et @."
  270.                  )
  271.                  nil ; ~:<newline> -> Newline ignorieren, Whitespace dalassen
  272.                )
  273.                (progn
  274.                  (when (csd-atsign-p newcsd)
  275.                    ; ~@<newline> -> Stringstück mit Newline zum Ausgeben
  276.                    (setf (csd-type newcsd) 1)
  277.                    (setf (csd-cs-index newcsd) (1- index))
  278.                    (setf (csd-data newcsd) index)
  279.                  )
  280.                  (setq index
  281.                    (or (position-if-not #'whitespacep control-string :start index)
  282.                        (length control-string)
  283.           ) )) ) ) )
  284.         ) ; tagbody zu Ende
  285.       ) ; loop zu Ende
  286.  
  287.       string-ended
  288.       (when stop-at
  289.         (format-error control-string index
  290.           #+DEUTSCH "Schließende Klammer '~A' fehlt."
  291.           #+ENGLISH "An opening directive is never closed; expecting '~A'."
  292.           #+FRANCAIS "Il manque la borne fermante '~A'."
  293.           stop-at
  294.       ) )
  295.  
  296.       end
  297.       (return (values index csdl))
  298. ) ) )
  299.  
  300. ;-------------------------------------------------------------------------------
  301.  
  302. (defvar *FORMAT-CS*) ; control-string
  303. (defvar *FORMAT-CSDL*) ; control-string directive list
  304. (defvar *FORMAT-ARG-LIST*) ; argument-list
  305. (defvar *FORMAT-NEXT-ARG*) ; pointer to next argument in argument-list
  306. (defvar *FORMAT-UP-AND-OUT* nil) ; reason for up-and-out
  307.  
  308. ; (format-error controlstring errorpos errorcode . arguments)
  309. ; signalisiert einen Error, der bei FORMAT aufgetreten ist. Die Stelle im
  310. ; Control-string wird mit einem Pfeil markiert.
  311. (defun format-error (controlstring errorpos errorstring &rest arguments)
  312.   (unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*))))
  313.   (setq errorstring
  314.     (sys::string-concat errorstring
  315.       #+DEUTSCH "~%Stelle im Kontrollstring:"
  316.       #+ENGLISH "~%Current point in control string:"
  317.       #+FRANCAIS "~%Position dans la chaîne de contrôle :"
  318.   ) )
  319.   (let ((pos1 0) (pos2 0))
  320.     (declare (simple-string errorstring) (fixnum pos1 pos2))
  321.     (loop
  322.       (setq pos2 (or (position #\Newline controlstring :start pos1)
  323.                      (length controlstring)
  324.       )          )
  325.       (setq errorstring (sys::string-concat errorstring "~%  ~A"))
  326.       (setq arguments
  327.         (nconc arguments (list (sys::substring controlstring pos1 pos2))) )
  328.       (when (<= pos1 errorpos pos2)
  329.         (setq errorstring (sys::string-concat errorstring "~%~VT"))
  330.         (setq arguments (nconc arguments (list (+ (- errorpos pos1) 2))))
  331.       )
  332.       (when (= pos2 (length controlstring)) (return))
  333.       (setq pos1 (+ pos2 1))
  334.   ) )
  335.   (apply #'error errorstring arguments)
  336. )
  337.  
  338. ;-------------------------------------------------------------------------------
  339.  
  340. (defun format (destination control-string &rest arguments)
  341.   (unless (stringp control-string)
  342.     (error
  343.       #+DEUTSCH "Kontrollstring muß ein String sein, nicht ~S"
  344.       #+ENGLISH "The control-string must be a string, not ~S"
  345.       #+FRANCAIS "La chaîne de contrôle doit être une chaîne et non ~S"
  346.       control-string
  347.   ) )
  348.   ; evtl. noch control-string zu einem Simple-String machen ??
  349.   (let ((node (list control-string)))
  350.     (format-parse-cs control-string 0 node nil)
  351.     (let* ((*FORMAT-CS*         (car node))
  352.            (*FORMAT-CSDL*       (cdr node))
  353.            (*FORMAT-ARG-LIST*   arguments)
  354.            (*FORMAT-NEXT-ARG*   *FORMAT-ARG-LIST*)
  355.            (*FORMAT-UP-AND-OUT* nil))
  356.       (cond ((null destination)
  357.              (let ((stream (make-string-output-stream)))
  358.                (format-interpret stream)
  359.                (get-output-stream-string stream)
  360.             ))
  361.             ((eq destination 'T)
  362.              (format-interpret *STANDARD-OUTPUT*)
  363.              nil
  364.             )
  365.             ((streamp destination)
  366.              (format-interpret destination)
  367.              nil
  368.             )
  369.             ((stringp destination)
  370.              (if (array-has-fill-pointer-p destination)
  371.                (let ((stream (sys::make-string-push-stream destination)))
  372.                  (format-interpret stream)
  373.                )
  374.                (error
  375.                  #+DEUTSCH "String zum Vollschreiben ~S hat keinen Fill-Pointer."
  376.                  #+ENGLISH "The destination string ~S should have a fill pointer."
  377.                  #+FRANCAIS "La chaîne destination n'a pas de pointeur de remplissage."
  378.                  destination
  379.              ) )
  380.              nil
  381.             )
  382.             (t (error
  383.                  #+DEUTSCH "Das ist weder NIL noch T noch ein Stream noch ein String: ~S"
  384.                  #+ENGLISH "The destination argument ~S is invalid (not NIL or T or a stream or a string)."
  385.                  #+FRANCAIS "L'argument de destination n'est ni NIL, ni T, ni un «stream» ni une chaîne : ~S"
  386.                  destination
  387.             )  )
  388. ) ) ) )
  389.  
  390. ;-------------------------------------------------------------------------------
  391.  
  392. ; (next-arg) liefert (und verbraucht) das nächste Argument aus der Argument-
  393. ; liste *FORMAT-NEXT-ARG*.
  394. (defun next-arg ()
  395.   (if (atom *FORMAT-NEXT-ARG*)
  396.     (format-error *FORMAT-CS* nil
  397.       #+DEUTSCH "Nicht genügend Argumente für diese Direktive übrig."
  398.       #+ENGLISH "There are not enough arguments left for this directive."
  399.       #+FRANCAIS "Il ne reste pas assez d'arguments pour cette directive."
  400.     )
  401.     (pop *FORMAT-NEXT-ARG*)
  402. ) )
  403.  
  404. ; (format-interpret stream [endmarker]) interpretiert *FORMAT-CSDL* ab.
  405. ; Fluid vars:
  406. ;   *FORMAT-ARG-LIST*
  407. ;   *FORMAT-NEXT-ARG*
  408. ;   *FORMAT-CS*
  409. ;   *FORMAT-CSDL*
  410. ;   *FORMAT-UP-AND-OUT*
  411. ; Abbruch des Interpretierens bei Antreffen der Direktive endmarker
  412. ; oder der Direktive ~; .
  413. (defun format-interpret (stream &optional (endmarker nil))
  414.   (loop
  415.     (when *FORMAT-UP-AND-OUT* (return))
  416.     (when (endp *FORMAT-CSDL*) (return))
  417.     (let ((csd (car *FORMAT-CSDL*)))
  418.       (case (csd-type csd)
  419.         (0 )
  420.         (1 (write-string *FORMAT-CS* stream
  421.              :start (csd-cs-index csd) :end (csd-data csd)
  422.         )  )
  423.         (2 (let ((directive-name (csd-data csd)))
  424.              (if (eq directive-name endmarker) (return))
  425.              (if (eq directive-name 'FORMAT-SEPARATOR) (return))
  426.              (apply directive-name
  427.                stream
  428.                (csd-colon-p csd)
  429.                (csd-atsign-p csd)
  430.                (format-resolve-parms csd)
  431.         )  ) )
  432.     ) )
  433.     (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  434. ) )
  435.  
  436. ; liefert die korrekte Argumentliste einer CSD, evtl. mit eingesetzten
  437. ; Parametern: V (als :NEXT-ARG) und # (als :ARG-COUNT) werden aufgelöst.
  438. (defun format-resolve-parms (csd)
  439.   (let ((arglist (csd-parm-list csd)))
  440.     (if (csd-v-or-#-p csd)
  441.       (mapcar #'(lambda (arg)
  442.                   (case arg
  443.                     (:NEXT-ARG (next-arg))
  444.                     (:ARG-COUNT (list-length *FORMAT-NEXT-ARG*))
  445.                     (T arg)
  446.                 ) )
  447.               arglist
  448.       )
  449.       arglist
  450. ) ) )
  451.  
  452. ; Bewegt den Stand des "Pointers in die Argumentliste" in eine Richtung.
  453. (defun format-goto-new-arg (backwardp index)
  454.   (if backwardp
  455.     ; rückwärts
  456.     (setq *FORMAT-NEXT-ARG*
  457.       (nthcdr
  458.         (max (- (list-length *FORMAT-ARG-LIST*) (list-length *FORMAT-NEXT-ARG*) index) 0)
  459.         *FORMAT-ARG-LIST*
  460.     ) )
  461.     ; vorwärts ist einfacher:
  462.     (setq *FORMAT-NEXT-ARG* (nthcdr index *FORMAT-NEXT-ARG*))
  463. ) )
  464.  
  465. ; gibt arg als römische Zahl auf stream aus, z.B. 4 als IIII.
  466. (defun format-old-roman (arg stream)
  467.   (unless (and (integerp arg) (<= 1 arg 4999))
  468.     (format-error *FORMAT-CS* nil
  469.       #+DEUTSCH "Die ~~:@R-Direktive erwartet ein Integer zwischen 1 und 4999, nicht ~S"
  470.       #+ENGLISH "The ~~:@R directive requires an integer in the range 1 - 4999, not ~S"
  471.       #+FRANCAIS "La directive ~~:@R requiert un entier compris entre 1 et 4999 et non ~S"
  472.       arg
  473.   ) )
  474.   (do ((charlistr  '(#\M  #\D #\C #\L #\X #\V #\I) (cdr charlistr))
  475.        (valuelistr '(1000 500 100 50  10   5   1) (cdr valuelistr))
  476.        (value arg (multiple-value-bind (multiplicity restvalue)
  477.                       (floor value (first valuelistr))
  478.                     (dotimes (i multiplicity)
  479.                       (write-char (first charlistr) stream)
  480.                     )
  481.                     restvalue
  482.       ))          )
  483.       ((zerop value))
  484. ) )
  485.  
  486. ; gibt arg als römische Zahl auf stream aus, z.B. 4 als IV.
  487. (defun format-new-roman (arg stream)
  488.   (unless (and (integerp arg) (<= 1 arg 3999))
  489.     (format-error *FORMAT-CS* nil
  490.       #+DEUTSCH "Die ~~@R-Direktive erwartet ein Integer zwischen 1 und 3999, nicht ~S"
  491.       #+ENGLISH "The ~~@R directive requires an integer in the range 1 - 3999, not ~S"
  492.       #+FRANCAIS "La directive ~~@R requiert un entier compris entre 1 et 3999 et non ~S"
  493.       arg
  494.   ) )
  495.   (do ((charlistr       '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
  496.        (valuelistr     '(1000 500 100 50  10   5   1 ) (cdr valuelistr))
  497.        (lowercharlistr  '(#\C #\C #\X #\X #\I #\I    ) (cdr lowercharlistr))
  498.        (lowervaluelistr '(100 100 10  10   1   1   0 ) (cdr lowervaluelistr))
  499.        (value arg
  500.          (multiple-value-bind (multiplicity restvalue)
  501.              (floor value (first valuelistr))
  502.            (dotimes (i multiplicity) (write-char (first charlistr) stream))
  503.            (let ((loweredvalue (- (first valuelistr) (first lowervaluelistr))))
  504.              (if (>= restvalue loweredvalue)
  505.                (progn
  506.                  (write-char (first lowercharlistr) stream)
  507.                  (write-char (first charlistr) stream)
  508.                  (- restvalue loweredvalue)
  509.                )
  510.                restvalue
  511.       )) ) ) )
  512.       ((zerop value))
  513. ) )
  514.  
  515. (defconstant FORMAT-CARDINAL-ONES
  516.   '#(NIL "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
  517.      "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
  518.      "seventeen" "eighteen" "nineteen"
  519. )   )
  520.  
  521. (defconstant FORMAT-CARDINAL-TENS
  522.   '#(NIL NIL "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")
  523. )
  524.  
  525. ; (format-small-cardinal arg stream) gibt eine ganze Zahl >0, <1000 im
  526. ; Klartext auf englisch auf den stream aus. (arg=0 -> gibt nichts aus.)
  527. (defun format-small-cardinal (arg stream)
  528.   (multiple-value-bind (hundreds tens-and-ones) (truncate arg 100)
  529.     (when (> hundreds 0)
  530.       (write-string (svref FORMAT-CARDINAL-ONES hundreds) stream)
  531.       (write-string " hundred" stream)
  532.     )
  533.     (when (> tens-and-ones 0)
  534.       (when (> hundreds 0) (write-string " and " stream))
  535.       (multiple-value-bind (tens ones) (truncate tens-and-ones 10)
  536.         (if (< tens 2)
  537.           (write-string (svref FORMAT-CARDINAL-ONES tens-and-ones) stream)
  538.           (progn
  539.             (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
  540.             (when (> ones 0)
  541.               (write-char #\- stream)
  542.               (write-string (svref FORMAT-CARDINAL-ONES ones) stream)
  543. ) ) ) ) ) ) )
  544.  
  545. ; (format-cardinal arg stream) gibt die ganze Zahl arg im Klartext auf englisch
  546. ; auf den Stream aus.
  547. (defun format-cardinal (arg stream) ; arg Integer
  548.   (if (zerop arg)
  549.     (write-string "zero" stream)
  550.     (progn
  551.       (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
  552.       (labels
  553.         ((blocks1000 (illions-list arg) ; Zerlegung in 1000er-Blöcke
  554.            (when (null illions-list)
  555.              (format-error *FORMAT-CS* nil
  556.                #+DEUTSCH "Zu großes Argument für ~~R-Direktive."
  557.                #+ENGLISH "The argument for the ~~R directive is too large."
  558.                #+FRANCAIS "L'argument pour la directive ~~R est trop grand."
  559.            ) )
  560.            (multiple-value-bind (thousands small) (truncate arg 1000)
  561.              (when (> thousands 0) (blocks1000 (cdr illions-list) thousands))
  562.              (when (> small 0)
  563.                (when (> thousands 0) (write-string ", " stream))
  564.                (format-small-cardinal small stream)
  565.                (write-string (car illions-list) stream)
  566.         )) ) )
  567.         (blocks1000
  568.           ; amerikanisch (billion=10^9)
  569.           '("" " thousand" " million" " billion" " trillion" " quadrillion"
  570.             " quintillion" " sextillion" " septillion" " octillion" " nonillion"
  571.             " decillion" " undecillion" " duodecillion" " tredecillion"
  572.             " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
  573.             " octodecillion" " novemdecillion" " vigintillion")
  574.           arg
  575. ) ) ) ) )
  576.  
  577. (defconstant FORMAT-ORDINAL-ONES
  578.   '#(NIL "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth"
  579.      "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
  580.      "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"
  581. )   )
  582.  
  583. ; (format-ordinal arg stream) gibt eine ganze Zahl arg als Abzählnummer im
  584. ; Klartext auf englisch auf den stream aus.
  585. (defun format-ordinal (arg stream) ; arg Integer
  586.   (if (zerop arg)
  587.     (write-string "zeroth" stream)
  588.     (progn
  589.       (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
  590.       (multiple-value-bind (hundreds tens-and-ones) (floor arg 100)
  591.         (when (> hundreds 0) (format-cardinal (* hundreds 100) stream))
  592.         (if (zerop tens-and-ones)
  593.           (write-string "th" stream)
  594.           (multiple-value-bind (tens ones) (floor tens-and-ones 10)
  595.             (when (> hundreds 0) (write-char #\Space stream))
  596.             (cond ((< tens 2)
  597.                    (write-string (svref FORMAT-ORDINAL-ONES tens-and-ones) stream)
  598.                   )
  599.                   ((zerop ones)
  600.                    (write-string
  601.                      (svref '#(NIL "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth"
  602.                                "sixtieth" "seventieth" "eightieth" "ninetieth")
  603.                             tens
  604.                      )
  605.                      stream
  606.                   ))
  607.                   (t (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
  608.                      (write-char #\- stream)
  609.                      (write-string (svref FORMAT-ORDINAL-ONES ones) stream)
  610. ) ) ) ) ) ) )     )
  611.  
  612. ; (format-padding count char stream) gibt count (ein Fixnum >=0) Zeichen char
  613. ; auf stream aus.
  614. (defun format-padding (count char stream)
  615.   (dotimes (i count) (write-char char stream))
  616. )
  617.  
  618. ; gibt auf den Stream stream aus:
  619. ; den String str, eventuell aufgefüllt mit Padding characters padchar.
  620. ; Und zwar so, daß die Breite mindestens mincol ist. Um das zu erreichen,
  621. ; werden mindestens minpad Zeichen eingefügt, eventuelle weitere dann in
  622. ; Blöcken à colinc Zeichen. Falls padleftflag, werden sie links eingefügt,
  623. ; sonst rechts vom String.
  624. (defun format-padded-string
  625.        (mincol colinc minpad padchar padleftflag str stream)
  626.   (let* ((need (+ (length str) minpad)) ; so viele Zeichen mindestens
  627.          (auxpad (if (< need mincol)
  628.                    (* (ceiling (- mincol need) colinc) colinc)
  629.                    0
  630.         ))       ) ; so viele Zeichen zusätzlich
  631.     (unless padleftflag (write-string str stream))
  632.     (format-padding (+ minpad auxpad) padchar stream)
  633.     (when padleftflag (write-string str stream))
  634. ) )
  635.  
  636. ; gibt den Integer arg auf den Stream aus:
  637. ; in Zahlenbasis base, mit Vorzeichen (+ nur falls >0 und positive-sign-flag),
  638. ; bei commaflag alle drei Stellen unterbrochen durch ein Zeichen commachar.
  639. ; Das Ganze links aufgefüllt mit padchar's, so daß die Gesamtbreite mindestens
  640. ; mincol ist.
  641. (defun format-integer (base
  642.                        mincol
  643.                        padchar
  644.                        commachar
  645.                        commaflag
  646.                        positive-sign-flag
  647.                        arg
  648.                        stream
  649.                       )
  650.   (let* ((*print-base* base)
  651.          (*print-radix* nil))
  652.     (if (and (zerop mincol) (not commaflag) (not positive-sign-flag))
  653.       (princ arg stream) ; normale Ausgabe tut's
  654.       (let* ((oldstring (princ-to-string arg))
  655.              (oldstring-length (length oldstring))
  656.              (number-of-digits
  657.                (if (minusp arg) (1- oldstring-length) oldstring-length) )
  658.              (number-of-commas
  659.                (if commaflag (floor (1- number-of-digits) 3) 0) )
  660.              (positive-sign (and positive-sign-flag (> arg 0)))
  661.              (newstring-length
  662.                (+ (if positive-sign 1 0) ; Vorzeichen
  663.                   oldstring-length number-of-commas ; Ziffern, Kommas
  664.              ) )
  665.              (newstring (make-string newstring-length)) )
  666.         ; Erst Vorzeichen +:
  667.         (when positive-sign (setf (schar newstring 0) #\+))
  668.         ; Dann oldstring in newstring übertragen, dabei Kommata überspringen:
  669.         (let ((oldpos oldstring-length) (newpos newstring-length))
  670.           (loop
  671.             (decf oldpos)
  672.             (when (minusp oldpos) (return))
  673.             (decf newpos)
  674.             (setf (schar newstring newpos) (schar oldstring oldpos))
  675.             (when (and (plusp number-of-commas)
  676.                        (zerop (mod (- oldstring-length oldpos) 3))
  677.                   ) ; noch ein Komma einzufügen?
  678.               (decf newpos)
  679.               (setf (schar newstring newpos) commachar)
  680.               (decf number-of-commas)
  681.         ) ) )
  682.         (if (zerop mincol)
  683.           (write-string newstring stream) ; schneller
  684.           (format-padded-string mincol 1 0 padchar t newstring stream)
  685. ) ) ) ) )
  686.  
  687. ; was ~D bei non-Integer-Argument tut: Argument mit ~A, aber dezimal ausgeben
  688. (defun format-ascii-decimal (arg stream)
  689.   (let ((*print-base* 10.)
  690.         (*print-radix* nil))
  691.     (princ arg stream)
  692. ) )
  693.  
  694. ; Unterprogramm für ~D, ~B, ~O, ~X:
  695. (defun format-base (base stream colon-modifier atsign-modifier
  696.                     mincol padchar commachar)
  697.   (if (null mincol) (setq mincol 0))
  698.   (if (null padchar) (setq padchar #\Space))
  699.   (if (null commachar) (setq commachar #\,))
  700.   (let ((arg (next-arg)))
  701.     (if (or (and (zerop mincol) (not colon-modifier) (not atsign-modifier))
  702.             (not (integerp arg))
  703.         )
  704.       (let ((*print-base* base)
  705.             (*print-radix* nil))
  706.         (princ arg stream)
  707.       )
  708.       (format-integer base mincol padchar commachar
  709.                       colon-modifier atsign-modifier arg stream
  710. ) ) ) )
  711.  
  712. ; (format-scale-exponent-aux arg null eins zehn zehntel lg2)
  713. ; liefert zur Floating-Point-Zahl arg >= 0 und
  714. ; null = 0.0, eins = 1.0, zehn = 10.0, zehntel = 0.1, lg2 = log(2)/log(10)
  715. ; (erste vier in derselben Floating-Point-Precision wie arg)
  716. ; zwei Werte: mantissa und n, mit
  717. ; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
  718. ; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
  719. ; (Bei arg=null: null und n=0.)
  720. (defun format-scale-exponent-aux (arg null eins zehn zehntel lg2)
  721.   (multiple-value-bind (significand expon) (decode-float arg)
  722.     (declare (ignore significand))
  723.     (if (zerop arg)
  724.       (values null 0)
  725.       (let* ((expon10a (truncate (* expon lg2))) ; nicht round, um Überlauf zu vermeiden
  726.              (signif10a (/ arg (expt zehn expon10a))))
  727.         (do ((zehnpot zehn (* zehnpot zehn))
  728.              (signif10b signif10a (/ signif10a zehnpot))
  729.              (expon10b expon10a (1+ expon10b)))
  730.             ((< signif10b eins)
  731.              (do ((zehnpot zehn (* zehnpot zehn))
  732.                   (signif10c signif10b (* signif10c zehnpot))
  733.                   (expon10c expon10b (1- expon10c)))
  734.                  ((>= signif10c zehntel)
  735.                   (values signif10c expon10c)
  736.              )   )
  737.         )   )
  738. ) ) ) )
  739.  
  740. ; (format-scale-exponent arg) liefert zur Floating-Point-Zahl arg >= 0
  741. ; zwei Werte: mantissa und n, mit
  742. ; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
  743. ; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
  744. ; (Bei arg=null: 0.0 und n=0.)
  745. (defun format-scale-exponent (arg)
  746.   (cond ((short-float-p arg)
  747.          (format-scale-exponent-aux arg 0.0s0 1.0s0 10.0s0 0.1s0 0.30103s0)
  748.         )
  749.         ((single-float-p arg)
  750.          (format-scale-exponent-aux arg 0.0f0 1.0f0 10.0f0 0.1f0 0.30103s0)
  751.         )
  752.         ((double-float-p arg)
  753.          (format-scale-exponent-aux arg 0.0d0 1.0d0 10.0d0 0.1d0 0.30103s0)
  754.         )
  755.         ((long-float-p arg)
  756.          (format-scale-exponent-aux arg
  757.            (float 0 arg) (float 1 arg) (float 10 arg) (float 1/10 arg)
  758.            0.30102999566d0 ; lg2 wird mit 32 Bit Genauigkeit gebraucht
  759. ) )     ))
  760.  
  761. ; (format-float-to-string arg width d k dmin)
  762. ; ergibt einen String zum Floating-point arg:
  763. ; er hat den Wert von (* (abs arg) (expt 10 k)), dabei mind. d Nachkommastellen
  764. ; und höchstens die Länge width (width=nil -> keine Einschränkung).
  765. ; Trotzdem wird nicht auf weniger als dmin Stellen gerundet.
  766. (let ((digit-string
  767.         (make-array 20 :element-type 'string-char :adjustable t :fill-pointer t)
  768.      ))
  769. (defun format-float-to-string (arg width d k dmin)
  770.   (if (zerop arg)
  771.     (let ((places (max (or d 0) (or dmin 0))))
  772.       (when width ; width angegeben -> places := (min places (1- width))
  773.         (when (>= places width) (setq places (1- width)))
  774.       )
  775.       (values
  776.         (let ((str (make-string (1+ places) :initial-element #\0)))
  777.           (setf (schar str 0) #\.)
  778.           str          ; ein Punkt und places Nullen
  779.         )
  780.         (1+ places)    ; Stellenzahl
  781.         t              ; Punkt ganz vorne
  782.         (zerop places) ; Punkt ganz hinten ?
  783.         0              ; Position des Punktes
  784.     ) )
  785.     (multiple-value-bind (significand expon) (integer-decode-float arg)
  786. ; significand : Integer >0
  787. ; expon : Integer
  788. ; mantprec : Anzahl der echten Mantissenbits von significand
  789. ; (also 2^mantprec <= significand < 2^(mantprec+1))
  790. ; width : Anzahl Stellen, die die Zahl (inklusive Punkt) nicht überschreiten
  791. ;         soll, oder NIL
  792. ; d : Mindestanzahl Nachkommastellen oder NIL
  793. ; k : Skalierungsfaktor (siehe CLTL S.394)
  794. ; dmin : Mindestanzahl von Dezimaltellen, die (trotz Angabe von width oder d)
  795. ;        nicht gerundet werden dürfen.
  796. ;        (Nur interessant, falls d <= dmin <= (precision der Zahl).)
  797. ; wandelt die Zahl significand*2^expon um in einen Dezimalstring um.
  798. ; Es ist kein Exponent dabei.
  799.       (let* ((mantprec (1- (float-digits arg)))
  800.              (numerator significand)
  801.              (denominator 1)
  802.              (abrund-einh 1) ; Abrundungseinheit:
  803.                ; Abrunden um 1 in der letzten abrundbaren Stelle entspricht
  804.                ; einer Erniedrigung von numerator um abrund-einh.
  805.              (aufrund-einh 1) ; Aufrundungseinheit:
  806.                ; Aufrunden um 1 in der letzten aufrundbaren Stelle entspricht
  807.                ; einer Erhöhung von numerator um aufrund-einh.
  808.              ; Stellen: 0 = 1. Stelle vor dem Punkt, -1 = 1. Stelle nach dem Punkt.
  809.              (stelle 0) ; Stelle der als nächstes auszugebenden Ziffer
  810.              (digit-count 0) ; Zahl der bisher in digit-string ausgegebenen
  811.                              ; Ziffern (exklusive den Punkt)
  812.              (point-pos 0) ; Punkt-Position = Zahl führender Stellen
  813.                            ; = Zahl der Ziffern vor dem Punkt
  814.              (letzte-stelle nil) ; NIL oder (falls d oder width angegeben waren)
  815.                            ; Stelle der letzten signifikanten Ziffer
  816.              (halbzahlig nil) ; zeigt an, ob hinten genau ein 0.500000 wegfällt
  817.              digit ; die laufende Ziffer, >=0, <10
  818.              (abrunden nil) ; T falls letzte Ziffer abzurunden ist
  819.              (aufrunden nil) ; T falls letzte Ziffer aufzurunden ist
  820.             )
  821.         (setf (fill-pointer digit-string) 0) ; digit-string leeren
  822.         (cond
  823.           ((> expon 0)
  824.            (setq numerator (ash significand expon))
  825.            (setq aufrund-einh (setq abrund-einh (ash 1 expon)))
  826.           )
  827.           ((< expon 0)
  828.            (setq denominator (ash 1 (- expon))) ; aufrund-einh = abrund-einh = 1
  829.         ) )
  830.         ; Zahl = numerator/denominator
  831.         (when (= significand (ash 1 mantprec))
  832.           ; Ist der Significand=2^mantprec, so ist abrund-einh zu halbieren.
  833.           ; Man kann stattdessen auch alle 3 anderen Grössen verdoppeln:
  834.           (setq aufrund-einh (ash aufrund-einh 1))
  835.           (setq numerator (ash numerator 1))
  836.           (setq denominator (ash denominator 1))
  837.         )
  838.         ; Defaultmäßig: Auf-/Abrunde-Einheit = eine Einheit in der letzten
  839.         ; BINÄRstelle.
  840.         ; Zahl = numerator/denominator
  841.         ; Skalierungsfaktor k in die Zahl mit einbeziehen (vgl. CLTL S.394)
  842.         ; k<0 -> Mantisse durch 10^(abs k) dividieren
  843.         ; k>0 -> Mantisse mit 10^k multiplizieren
  844.         ; Dabei aufrund-einh, abrund-einh im Verhältnis zu numerator beibehalten.
  845.         (when k
  846.           (if (< k 0)
  847.             (let ((skal-faktor (expt 10 (- k))))
  848.               (setq denominator (* denominator skal-faktor))
  849.             )
  850.             (let ((skal-faktor (expt 10 k)))
  851.               (setq numerator (* numerator skal-faktor))
  852.               (setq aufrund-einh (* aufrund-einh skal-faktor))
  853.               (setq abrund-einh (* abrund-einh skal-faktor))
  854.             )
  855.         ) )
  856.         ; auf >= 1/10 adjustieren:
  857.         ; (jeweils numerator mit 10 multiplizieren, eine führende 0 mehr vorsehen)
  858.         (do ()
  859.             ((>= (* numerator 10) denominator))
  860.           (setq stelle (1- stelle))
  861.           (setq numerator (* numerator 10))
  862.           (setq abrund-einh (* abrund-einh 10))
  863.           (setq aufrund-einh (* aufrund-einh 10))
  864.         )
  865.         ; stelle = Stelle der letzten führenden 0
  866.         ;        = 1 + Stelle der 1. signifikanten Ziffer
  867.         ;        oder =0, falls k>=0
  868.         ; Ausführung der Rundung:
  869.         (loop
  870.           ; Solange das Ergebnis auch nach Aufrundung >= 1 bliebe,
  871.           ; eine Vorkommastelle mehr einplanen:
  872.           (do ()
  873.               ((< (+ (ash numerator 1) aufrund-einh) (ash denominator 1)))
  874.             (setq denominator (* denominator 10))
  875.             (setq stelle (1+ stelle))
  876.           )
  877.           ; Falls d oder width angegeben:
  878.           ; letzte-stelle ausrechnen
  879.           (if d
  880.             ; Falls dmin angegeben: (min (- d) (- dmin)) = (- (max d dmin)).
  881.             ; Sonst (- d).
  882.             (progn
  883.               (setq letzte-stelle (- d))
  884.               (when (and dmin (> letzte-stelle (- dmin)))
  885.                 (setq letzte-stelle (- dmin))
  886.             ) )
  887.             ; Falls nicht d, nur width angegeben:
  888.             (when width
  889.               (if (< stelle 0)
  890.                 ; Es kommen führende Nullen nach dem Punkt -> d:=(1- width)
  891.                 (setq letzte-stelle (- 1 width))
  892.                 ; Es kommen keine führenden Nullen nach dem Punkt ->
  893.                 ; Es wird stelle Vorkommaziffern geben, d:=(- (1- width) stelle)
  894.                 (setq letzte-stelle (1+ (- stelle width)))
  895.               )
  896.               ; also letzte-stelle = (- (- (1- width) (max stelle 0)))
  897.               ; wieder dmin berücksichtigen:
  898.               (when (and dmin (> letzte-stelle (- dmin)))
  899.                 (setq letzte-stelle (- dmin))
  900.           ) ) )
  901.           (when (or d width)
  902.             (let* ((ziffernzahl (- letzte-stelle stelle))
  903.                    ; ziffernzahl = Zahl signifikanter Stellen oder <0.
  904.                    (dezimal-einh denominator))
  905.               ; dezimal-einh := (ceiling (* dezimal-einh (expt 10 ziffernzahl)))
  906.               (if (>= ziffernzahl 0)
  907.                 (dotimes (i ziffernzahl)
  908.                   (setq dezimal-einh (* dezimal-einh 10))
  909.                 )
  910.                 (dotimes (i (- ziffernzahl))
  911.                   (setq dezimal-einh (ceiling dezimal-einh 10))
  912.                 )
  913.               )
  914.               ; dezimal-einh = Um wieviel numerator erhöht bzw. erniedigt werden
  915.               ; müßte, damit sich die Dezimaldarstellung um genau 1 an der
  916.               ; Position letzte-stelle verändert.
  917.               (setq abrund-einh (max dezimal-einh abrund-einh))
  918.               (setq aufrund-einh (max dezimal-einh aufrund-einh))
  919.               ; Jetzt darf auch um eine (halbe) DEZIMAL-Einheit gerundet werden.
  920.               (when (= aufrund-einh dezimal-einh) (setq halbzahlig T))
  921.           ) )
  922.           (when (< (+ (ash numerator 1) aufrund-einh) (ash denominator 1))
  923.             (return)
  924.         ) )
  925.         ; stelle = Position der ersten signifikanten Stelle + 1
  926.         ; Führenden Punkt und nachfolgende Nullen ausgeben:
  927.         (when (< stelle 0)
  928.           (setq point-pos digit-count)
  929.           (vector-push-extend #\. digit-string)
  930.           (dotimes (i (- stelle))
  931.             (incf digit-count)
  932.             (vector-push-extend #\0 digit-string)
  933.         ) )
  934.         ; Ziffern der Mantisse ausgeben:
  935.         (loop
  936.           (when (zerop stelle)
  937.             (vector-push-extend #\. digit-string)
  938.             (setq point-pos digit-count)
  939.           )
  940.           (decf stelle)
  941.           (multiple-value-setq (digit numerator)
  942.             (truncate (* numerator 10) denominator)
  943.           )
  944.           (setq abrund-einh (* abrund-einh 10))
  945.           (setq aufrund-einh (* aufrund-einh 10))
  946.           (setq abrunden (< (ash numerator 1) abrund-einh))
  947.           (if halbzahlig
  948.             (setq aufrunden
  949.               (>= (ash numerator 1) (- (ash denominator 1) aufrund-einh))
  950.             )
  951.             (setq aufrunden
  952.               (> (ash numerator 1) (- (ash denominator 1) aufrund-einh))
  953.             )
  954.           )
  955.           (when (or abrunden aufrunden
  956.                     (and letzte-stelle (<= stelle letzte-stelle))
  957.                 )
  958.             (return)
  959.           )
  960.           (vector-push-extend (schar "0123456789" digit) digit-string)
  961.           (incf digit-count)
  962.         )
  963.         ; letzte signifikante Ziffer ausgeben:
  964.         (when (or (null letzte-stelle) (>= stelle letzte-stelle))
  965.           (vector-push-extend
  966.             (schar "0123456789"
  967.               (cond
  968.                 ((and abrunden (not aufrunden)) digit)
  969.                 ((and aufrunden (not abrunden)) (1+ digit))
  970.                 ((<= (ash numerator 1) denominator) digit)
  971.                 (t (1+ digit))
  972.             ) )
  973.             digit-string
  974.           )
  975.           (incf digit-count)
  976.         )
  977.         ; Nachfolgende Nullen und Punkt ausgeben
  978.         (when (>= stelle 0)
  979.           (dotimes (i stelle)
  980.             (incf digit-count)
  981.             (vector-push-extend #\0 digit-string)
  982.           )
  983.           (vector-push-extend #\. digit-string)
  984.           (setq point-pos digit-count)
  985.         )
  986.         (when d
  987.           (dotimes (i (- d (- digit-count point-pos)))
  988.             (incf digit-count)
  989.             (vector-push-extend #\0 digit-string)
  990.         ) )
  991.         (values
  992.                   digit-string               ; Ziffern
  993.                   (1+ digit-count)           ; Anzahl der Ziffern
  994.                   (= point-pos 0)            ; Punkt ganz vorne?
  995.                   (= point-pos digit-count)  ; Punkt ganz hinten?
  996.                   point-pos                  ; Position des Punktes
  997.         ) ; 5 Werte
  998. ) ) ) )
  999. )
  1000.  
  1001. ; (format-float-for-f w d k overflowchar padchar plus-sign-flag arg stream)
  1002. ; gibt die Floating-Point-Zahl arg in Festkommadarstellung auf stream aus.
  1003. (defun format-float-for-f (w d k overflowchar padchar plus-sign-flag arg stream)
  1004.   (let ((width (if w (if (or plus-sign-flag (minusp arg)) (1- w) w) nil)))
  1005.     ; width = zur Verfügung stehende Zeichen ohne Vorzeichen
  1006.     (multiple-value-bind (digits digitslength leadingpoint trailingpoint)
  1007.         (format-float-to-string arg width d k nil)
  1008.       (when (eql d 0) (setq trailingpoint nil)) ; d=0 -> keine Zusatz-Null hinten
  1009.       (when w
  1010.         (setq width (- width digitslength))
  1011.         (when leadingpoint ; evtl. Zusatz-Null vorne einplanen
  1012.           (if (> width 0) (setq width (1- width)) (setq leadingpoint nil))
  1013.         )
  1014.         (when trailingpoint ; evtl. Zusatz-Null hinten einplanen
  1015.           (if (> width 0) (setq width (1- width)) (setq trailingpoint nil))
  1016.         )
  1017.       )
  1018.       ; Es bleiben noch width Zeichen übrig.
  1019.       (if (and overflowchar w (minusp width))
  1020.         (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
  1021.         (progn
  1022.           (when (and w (> width 0)) (format-padding width padchar stream))
  1023.           (if (minusp arg)
  1024.             (write-char #\- stream)
  1025.             (if plus-sign-flag (write-char #\+ stream))
  1026.           )
  1027.           (when leadingpoint (write-char #\0 stream))
  1028.           (write-string digits stream)
  1029.           (when trailingpoint (write-char #\0 stream))
  1030.       ) )
  1031. ) ) )
  1032.  
  1033. ; (format-float-for-e w d e k overflowchar padchar exponentchar plus-sign-flag
  1034. ;                     arg stream)
  1035. ; gibt die Floating-point-Zahl arg in Exponentialdarstellung auf den stream aus.
  1036. ; (vgl. CLTL S.392-394)
  1037. ; Aufteilung der Mantisse:
  1038. ;   Falls k<=0, erst 1 Null (falls von der Breite her passend), dann der Punkt,
  1039. ;               dann |k| Nullen, dann d-|k| signifikante Stellen;
  1040. ;               zusammen also d Nachkommastellen.
  1041. ;   Falls k>0,  erst k signifikante Stellen, dann der Punkt,
  1042. ;               dann weitere d-k+1 signifikante Stellen;
  1043. ;               zusammen also d+1 signifikante Stellen. Keine Nullen vorne.
  1044. ;   (Der Defaultwert in FORMAT-EXPONENTIAL-FLOAT ist k=1.)
  1045. ; Vor der Mantisse das Vorzeichen (ein + nur falls arg>=0 und plus-sign-flag).
  1046. ; Dann der Exponent, eingeleitet durch exponentchar, dann Vorzeichen des
  1047. ; Exponenten (stets + oder -), dann e Stellen für den Exponenten.
  1048. ; Dann wird das Ganze mit padchars auf w Zeichen Breite aufgefüllt.
  1049. ; Sollte das (auch nach evtl. Unterdrückung einer führenden Null) mehr als
  1050. ; w Zeichen ergeben, so werden statt dessen w overflowchars ausgegeben, oder
  1051. ; (falls overflowchar = nil) die Zahl mit so vielen Stellen wie nötig
  1052. ; ausgegeben.
  1053. (defun format-float-for-e (w d e k
  1054.        overflowchar padchar exponentchar plus-sign-flag arg stream)
  1055.   (multiple-value-bind (mantissa oldexponent) (format-scale-exponent (abs arg))
  1056.     (let* ((exponent (if (zerop arg) 0 (- oldexponent k))) ; auszugebender Exponent
  1057.            (expdigits (write-to-string (abs exponent) :base 10. :radix nil))
  1058.            (expdigitsneed (if e (max (length expdigits) e) (length expdigits)))
  1059.            ; expdigitsneed = Anzahl der Stellen, die für die Ziffern des
  1060.            ; Exponenten nötig sind.
  1061.            (mantd (if d (if (> k 0) (1+ (- d k)) d) nil))
  1062.            ; mantd = Anzahl der Mantissenstellen hinter dem Punkt
  1063.            (dmin (if (minusp k) (- 1 k) nil)) ; nachher: fordere, daß
  1064.            ; nicht in die ersten (+ 1 (abs k)) Stellen hineingerundet wird.
  1065.            (mantwidth (if w (- w 2 expdigitsneed) nil))
  1066.            ; mantwidth = Anzahl der für die Mantisse (inkl. Vorzeichen, Punkt)
  1067.            ; zur Verfügung stehenden Zeichen (oder nil)
  1068.           )
  1069.       (declare (simple-string expdigits) (fixnum exponent expdigitsneed))
  1070.       (if (and overflowchar w e (> expdigitsneed e))
  1071.         ; Falls Overflowchar und w und e angegeben, Exponent mehr braucht:
  1072.         (format-padding w overflowchar stream)
  1073.         (progn
  1074.           (if w
  1075.             (if (or plus-sign-flag (minusp arg)) (setq mantwidth (1- mantwidth)))
  1076.           )
  1077.           ; mantwidth = Anzahl der für die Mantisse (ohne Vorzeichen,
  1078.           ; inklusive Punkt) zur Verfügung stehenden Zeichen (oder nil)
  1079.           (multiple-value-bind (mantdigits mantdigitslength
  1080.                                 leadingpoint trailingpoint)
  1081.               (format-float-to-string mantissa mantwidth mantd k dmin)
  1082.             (when w
  1083.               (setq mantwidth (- mantwidth mantdigitslength))
  1084.               (if trailingpoint
  1085.                 (if (or (null mantd) (> mantd 0))
  1086.                   (setq mantwidth (- mantwidth 1))
  1087.                   (setq trailingpoint nil)
  1088.               ) )
  1089.               (if leadingpoint
  1090.                 (if (> mantwidth 0)
  1091.                   (setq mantwidth (- mantwidth 1))
  1092.                   (setq leadingpoint nil)
  1093.               ) )
  1094.             )
  1095.             ; Es bleiben noch mantwidth Zeichen übrig.
  1096.             (if (and overflowchar w (minusp mantwidth))
  1097.               (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
  1098.               (progn
  1099.                 (when (and w (> mantwidth 0))
  1100.                   (format-padding mantwidth padchar stream)
  1101.                 )
  1102.                 (if (minusp arg)
  1103.                   (write-char #\- stream)
  1104.                   (if plus-sign-flag (write-char #\+ stream))
  1105.                 )
  1106.                 (if leadingpoint (write-char #\0 stream))
  1107.                 (write-string mantdigits stream)
  1108.                 (if trailingpoint (write-char #\0 stream))
  1109.                 (write-char
  1110.                   (cond (exponentchar)
  1111.                         ((typep arg *READ-DEFAULT-FLOAT-FORMAT*) #\E)
  1112.                         ((short-float-p arg) #\s)
  1113.                         ((single-float-p arg) #\f)
  1114.                         ((double-float-p arg) #\d)
  1115.                         ((long-float-p arg) #\L)
  1116.                   )
  1117.                   stream
  1118.                 )
  1119.                 (write-char (if (minusp exponent) #\- #\+) stream)
  1120.                 (when (and e (> e (length expdigits)))
  1121.                   (format-padding (- e (length expdigits)) #\0 stream)
  1122.                 )
  1123.                 (write-string expdigits stream)
  1124.           ) ) )
  1125.     ) ) )
  1126. ) )
  1127.  
  1128. ; Rückt *FORMAT-CSDL* vor bis zum Ende des momentanen ~[ bzw. ~{ bzw. ~< .
  1129. (defun format-skip-to-end ()
  1130.   (do ()
  1131.       ((null (csd-clause-chain (car *FORMAT-CSDL*))))
  1132.     (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1133. ) )
  1134.  
  1135. ; (format-justified-segments mincol colinc minpad justify-left justify-right
  1136. ;   piecelist) berechnet, an welchen Stellen zwischen den einzelnen Strings in
  1137. ; piecelist wieviele Leerstellen zu setzen sind.
  1138. ; Zwischen die einzelnen Strings aus piecelist (auch vorher, falls justify-left;
  1139. ; auch nachher, falls justify-right) werden mindestens minpad padding-characters
  1140. ; eingefügt. Dann werden nochmals weitere padding-characters dazugenommen,
  1141. ; damit die Gesamtbreite >= mincol wird. Ist die Breite > mincol, werden weitere
  1142. ; padding-characters dazugenommen, so daß die Breite von der Form
  1143. ; mincol + k * colinc wird. Diese padding-characters werden auf die einzelnen
  1144. ; Stellen gleichmäßig verteilt.
  1145. ; 1. Wert: Ein Vektor, der zu jeder Stelle angibt, wieviele padding-characters
  1146. ; einzufügen sind (NIL = keine).
  1147. ; Erstes Element: ganz links, zweites: nach 1. String, ..., letztes: rechts.
  1148. ; 2. Wert: Die sich ergebende Gesamtbreite.
  1149. (defun format-justified-segments
  1150.        (mincol colinc minpad justify-left justify-right piecelist)
  1151.   (declare (fixnum mincol colinc minpad))
  1152.   (let ((piecesnumber 0)
  1153.         (pieceswidth 0))
  1154.     (dolist (piece piecelist)
  1155.       (declare (simple-string piece))
  1156.       (incf piecesnumber)
  1157.       (incf pieceswidth (length piece))
  1158.     )
  1159.     (let* ((new-justify-left
  1160.              (or justify-left (and (= piecesnumber 1) (not justify-right))))
  1161.            (padblocks (+ piecesnumber -1       ; Anzahl der Einfüge-Stellen
  1162.                          (if new-justify-left 1 0) (if justify-right 1 0)
  1163.            )          )
  1164.            (width-need (+ pieceswidth (* padblocks minpad)))
  1165.            (width (+ mincol
  1166.                      (if (<= width-need mincol)
  1167.                          0
  1168.                          (* (ceiling (- width-need mincol) colinc) colinc)
  1169.           ))      )  )
  1170.       (declare (fixnum piecesnumber pieceswidth padblocks width-need width))
  1171.       (multiple-value-bind (padwidth rest) (floor (- width pieceswidth) padblocks)
  1172.         (let ((padblock-lengths
  1173.                 (make-array (1+ piecesnumber) :initial-element padwidth)
  1174.              ))
  1175.           (unless new-justify-left (setf (svref padblock-lengths 0) nil))
  1176.           (unless justify-right (setf (svref padblock-lengths piecesnumber) nil))
  1177.           (do ((i 0 (1+ i)))
  1178.               ((zerop rest))
  1179.             (when (svref padblock-lengths i)
  1180.               (incf (svref padblock-lengths i))
  1181.               (decf rest)
  1182.           ) )
  1183.           (values padblock-lengths width)
  1184. ) ) ) ) )
  1185.  
  1186. ;-------------------------------------------------------------------------------
  1187.  
  1188. ; ~A CLTL S.387-388
  1189. (defun format-ascii (stream colon-modifier atsign-modifier
  1190.              &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1191.   (if (null mincol) (setq mincol 0))
  1192.   (if (null colinc) (setq colinc 1))
  1193.   (if (null minpad) (setq minpad 0))
  1194.   (if (null padchar) (setq padchar #\Space))
  1195.   (let ((arg (next-arg)))
  1196.     (when (and colon-modifier (null arg)) (setq arg "()"))
  1197.     (if (and (zerop mincol) (zerop minpad))
  1198.       (princ arg stream)
  1199.       (format-padded-string mincol colinc minpad padchar
  1200.         atsign-modifier ; =: padleftflag
  1201.         (princ-to-string arg)
  1202.         stream
  1203. ) ) ) )
  1204.  
  1205. ; ~S CLTL S.388
  1206. (defun format-s-expression (stream colon-modifier atsign-modifier
  1207.              &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1208.   (if (null mincol) (setq mincol 0))
  1209.   (if (null colinc) (setq colinc 1))
  1210.   (if (null minpad) (setq minpad 0))
  1211.   (if (null padchar) (setq padchar #\Space))
  1212.   (let ((arg (next-arg)))
  1213.     (if (and (zerop mincol) (zerop minpad))
  1214.       (if (and colon-modifier (null arg))
  1215.         (write-string "()" stream)
  1216.         (prin1 arg stream)
  1217.       )
  1218.       (format-padded-string mincol colinc minpad padchar
  1219.         atsign-modifier ; =: padleftflag
  1220.         (if (and colon-modifier (null arg)) "()" (prin1-to-string arg))
  1221.         stream
  1222. ) ) ) )
  1223.  
  1224. ; ~W
  1225. (defun format-write (stream colon-modifier atsign-modifier
  1226.              &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1227.   (declare (ignore colon-modifier))
  1228.   (if (null mincol) (setq mincol 0))
  1229.   (if (null colinc) (setq colinc 1))
  1230.   (if (null minpad) (setq minpad 0))
  1231.   (if (null padchar) (setq padchar #\Space))
  1232.   (let ((arg (next-arg)))
  1233.     (if (and (zerop mincol) (zerop minpad))
  1234.       (write arg :stream stream)
  1235.       (format-padded-string mincol colinc minpad padchar
  1236.         atsign-modifier ; =: padleftflag
  1237.         (write-to-string arg)
  1238.         stream
  1239. ) ) ) )
  1240.  
  1241. ; ~D, CLTL S.388
  1242. (defun format-decimal (stream colon-modifier atsign-modifier
  1243.                        &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1244.   (format-base 10 stream colon-modifier atsign-modifier mincol padchar commachar)
  1245. )
  1246.  
  1247. ; ~B, CLTL S.388
  1248. (defun format-binary (stream colon-modifier atsign-modifier
  1249.                       &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1250.   (format-base 2 stream colon-modifier atsign-modifier mincol padchar commachar)
  1251. )
  1252.  
  1253. ; ~O, CLTL S.388
  1254. (defun format-octal (stream colon-modifier atsign-modifier
  1255.                      &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1256.   (format-base 8 stream colon-modifier atsign-modifier mincol padchar commachar)
  1257. )
  1258.  
  1259. ; ~X, CLTL S.388-389
  1260. (defun format-hexadecimal (stream colon-modifier atsign-modifier
  1261.                         &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1262.   (format-base 16 stream colon-modifier atsign-modifier mincol padchar commachar)
  1263. )
  1264.  
  1265. ; ~R, CLTL S.389
  1266. (defun format-radix (stream colon-modifier atsign-modifier
  1267.             &optional (radix nil) (mincol 0) (padchar #\Space) (commachar #\,))
  1268.   (if (null mincol) (setq mincol 0))
  1269.   (if (null padchar) (setq padchar #\Space))
  1270.   (if (null commachar) (setq commachar #\,))
  1271.   (let ((arg (next-arg)))
  1272.     (if radix
  1273.       (format-integer radix mincol padchar commachar
  1274.                       colon-modifier atsign-modifier
  1275.                       arg stream
  1276.       )
  1277.       (if atsign-modifier
  1278.         (if (integerp arg)
  1279.           (if colon-modifier
  1280.             (format-old-roman arg stream)
  1281.             (format-new-roman arg stream)
  1282.           )
  1283.           (format-error *FORMAT-CS* nil
  1284.             #+DEUTSCH "Die ~~R- und ~~:R-Direktiven erwarten ein Integer als Argument, nicht ~S"
  1285.             #+ENGLISH "The ~~R and ~~:R directives require an integer argument, not ~S"
  1286.             #+FRANCAIS "Les directives ~~R et ~~:R nécessitent un argument de type entier et non ~S"
  1287.             arg
  1288.         ) )
  1289.         (if colon-modifier
  1290.           (format-ordinal arg stream)
  1291.           (format-cardinal arg stream)
  1292. ) ) ) ) )
  1293.  
  1294. ; ~P, CLTL S. 389
  1295. (defun format-plural (stream colon-modifier atsign-modifier)
  1296.   (when colon-modifier (format-goto-new-arg t 1))
  1297.   (let ((singular (eql (next-arg) 1)))
  1298.     (if atsign-modifier
  1299.       (write-string (if singular "y" "ies") stream)
  1300.       (unless singular (write-char #\s stream))
  1301. ) ) )
  1302.  
  1303. ; ~C, CLTL S.389-390
  1304. (defun format-character (stream colon-modifier atsign-modifier)
  1305.   (let ((arg (next-arg)))
  1306.     (unless (characterp arg)
  1307.       (format-error *FORMAT-CS* nil
  1308.         #+DEUTSCH "Die ~~C-Direktive erwartet ein Character, nicht ~S"
  1309.         #+ENGLISH "The ~~C directive requires a character argument, not ~S"
  1310.         #+FRANCAIS "La directive ~~C requiert un caractère et non ~S"
  1311.         arg
  1312.     ) )
  1313.     (flet ((write-charname (arg)
  1314.              (let ((name (char-name arg)))
  1315.                (if name
  1316.                  (write-string (string-capitalize name) stream)
  1317.                  (write-char arg stream)
  1318.           )) ) )
  1319.       (if (not atsign-modifier)
  1320.         ; ~C oder ~:C
  1321.         (progn
  1322.           (dolist (name '(:CONTROL :META :SUPER :HYPER))
  1323.             (when (char-bit arg name)
  1324.               (write-string (string-capitalize (symbol-name name)) stream
  1325.                             :end (if colon-modifier nil 1)
  1326.               )
  1327.               (write-char #\- stream)
  1328.           ) )
  1329.           (write-charname (make-char arg))
  1330.         )
  1331.         (if (not colon-modifier)
  1332.           ; ~@C
  1333.           (prin1 arg stream)
  1334.           ; ~:@C -- hier NUR die Anweisung, wie's zu tippen ist.
  1335.           (progn
  1336.             (let ((keynames '("Shift-" "Control-" "Alternate-")))
  1337.               (dolist (name '(:SUPER :CONTROL :META))
  1338.                 (when (char-bit arg name)
  1339.                   (write-string (car keynames) stream)
  1340.                   (setq arg (set-char-bit arg name nil))
  1341.                 )
  1342.                 (setq keynames (cdr keynames))
  1343.             ) )
  1344.             (let* ((hyperkey-alist
  1345.                      #+(or ATARI DOS OS/2 UNIX VMS)
  1346.                      '(
  1347.        #-(or UNIX VMS) (#\Enter  . "Enter" )
  1348.                        (#\Insert . "Insert")
  1349.                        (#\End    . "End"   )
  1350.                        (#\Down   . #-ATARI "Down"  #+ATARI "")
  1351.                        (#\PgDn   . "PgDn"  )
  1352.                        (#\Left   . #-ATARI "Left"  #+ATARI "")
  1353.        #+(or UNIX VMS) (#\Center . "Center")
  1354.                        (#\Right  . #-ATARI "Right" #+ATARI "")
  1355.                        (#\Home   . #-ATARI "Home"  #+ATARI "Clr/Home")
  1356.                        (#\Up     . #-ATARI "Up"    #+ATARI "")
  1357.                        (#\PgUp   . "PgUp"  )
  1358.                #+ATARI (#\Help   . "Help"  )
  1359.                #+ATARI (#\Undo   . "Undo"  )
  1360.        #+(or DOS OS/2) (#\Prtscr . "PrtScr")
  1361.        #-(or UNIX VMS) (#\Delete . "Delete")
  1362.                        (#\F1     . "F1"    )
  1363.                        (#\F2     . "F2"    )
  1364.                        (#\F3     . "F3"    )
  1365.                        (#\F4     . "F4"    )
  1366.                        (#\F5     . "F5"    )
  1367.                        (#\F6     . "F6"    )
  1368.                        (#\F7     . "F7"    )
  1369.                        (#\F8     . "F8"    )
  1370.                        (#\F9     . "F9"    )
  1371.                        (#\F10    . "F10"   )
  1372.                        (#\F11    . "F11"   )
  1373.                        (#\F12    . "F12"   )
  1374.                       )
  1375.                      #-(or ATARI DOS OS/2 UNIX VMS)
  1376.                      '()
  1377.                    )
  1378.                    (acons (assoc arg hyperkey-alist)))
  1379.               (if acons
  1380.                 (write-string (cdr acons) stream)
  1381.                 (progn
  1382.                   (when (char-bit arg ':HYPER)
  1383.                     (write-string #+DEUTSCH "Ziffernblock-"
  1384.                                   #+ENGLISH "Keypad-"
  1385.                                   #+FRANCAIS "Keypad-" ; ??
  1386.                                   stream
  1387.                     )
  1388.                     (setq arg (set-char-bit arg :HYPER nil))
  1389.                   )
  1390.                   (write-charname arg)
  1391.           ) ) ) )
  1392. ) ) ) ) )
  1393.  
  1394. ; ~F, CLTL S.390-392
  1395. (defun format-fixed-float (stream colon-modifier atsign-modifier
  1396.        &optional (w nil) (d nil) (k 0) (overflowchar nil) (padchar #\Space))
  1397.   (declare (ignore colon-modifier))
  1398.   (if (null k) (setq k 0))
  1399.   (if (null padchar) (setq padchar #\Space))
  1400.   (let ((arg (next-arg)))
  1401.     (when (rationalp arg) (setq arg (float arg)))
  1402.     (if (floatp arg)
  1403.       (format-float-for-f w d k overflowchar padchar atsign-modifier arg stream)
  1404.       (format-ascii-decimal arg stream)
  1405. ) ) )
  1406.  
  1407. ; ~E, CLTL S.392-395
  1408. (defun format-exponential-float (stream colon-modifier atsign-modifier
  1409.           &optional (w nil) (d nil) (e nil) (k 1)
  1410.                     (overflowchar nil) (padchar #\Space) (exponentchar nil))
  1411.   (declare (ignore colon-modifier))
  1412.   (if (null k) (setq k 1))
  1413.   (if (null padchar) (setq padchar #\Space))
  1414.   (let ((arg (next-arg)))
  1415.     (when (rationalp arg) (setq arg (float arg)))
  1416.     (if (floatp arg)
  1417.       (format-float-for-e w d e k overflowchar padchar exponentchar
  1418.                           atsign-modifier arg stream
  1419.       )
  1420.       (format-ascii-decimal arg stream)
  1421. ) ) )
  1422.  
  1423. ; ~G, CLTL S.395-396
  1424. (defun format-general-float (stream colon-modifier atsign-modifier
  1425.           &optional (w nil) (d nil) (e nil) (k 1)
  1426.                     (overflowchar nil) (padchar #\Space) (exponentchar nil))
  1427.   (declare (ignore colon-modifier))
  1428.   (if (null k) (setq k 1))
  1429.   (if (null padchar) (setq padchar #\Space))
  1430.   (let ((arg (next-arg)))
  1431.     (if (rationalp arg) (setq arg (float arg)))
  1432.     (if (floatp arg)
  1433.       (multiple-value-bind (mantissa n) (format-scale-exponent (abs arg))
  1434.         (declare (ignore mantissa))
  1435.         (if (null d)
  1436.           (setq d
  1437.             (multiple-value-bind (digits digitslength)
  1438.               (format-float-to-string (abs arg) nil nil nil nil)
  1439.               (declare (ignore digits))
  1440.               (max (max (1- digitslength) 1) (min n 7))
  1441.         ) ) )
  1442.         (let* ((ee (if e (+ 2 e) 4))
  1443.                (dd (- d n)))
  1444.           (if (<= 0 dd d)
  1445.             (progn
  1446.               (format-float-for-f
  1447.                 (if w (- w ee) nil)
  1448.                 dd 0
  1449.                 overflowchar padchar atsign-modifier arg stream
  1450.               )
  1451.               (format-padding ee #\Space stream)
  1452.             )
  1453.             (format-float-for-e w d e k overflowchar padchar exponentchar
  1454.                                 atsign-modifier arg stream
  1455.       ) ) ) )
  1456.       (format-ascii-decimal arg stream)
  1457. ) ) )
  1458.  
  1459. ; ~$, CLTL S.396-397
  1460. (defun format-dollars-float (stream colon-modifier atsign-modifier
  1461.           &optional (d 2) (n 1) (w 0) (padchar #\Space) )
  1462.   (if (null d) (setq d 2))
  1463.   (if (null n) (setq n 1))
  1464.   (if (null w) (setq w 0))
  1465.   (if (null padchar) (setq padchar #\Space))
  1466.   (let ((arg (next-arg)))
  1467.     (when (rationalp arg) (setq arg (float arg)))
  1468.     (if (floatp arg)
  1469.       (multiple-value-bind (digits digitslength
  1470.                             leadingpoint trailingpoint leadings)
  1471.         (format-float-to-string arg nil d 0 nil)
  1472.         (declare (ignore digitslength leadingpoint trailingpoint))
  1473.         (let* ((lefts (max leadings n))
  1474.                (totalwidth (+ (if (or atsign-modifier (minusp arg)) 1 0)
  1475.                               lefts 1 d
  1476.                )           )
  1477.                (padcount (max (- w totalwidth) 0)))
  1478.           (if (not colon-modifier) (format-padding padcount padchar stream))
  1479.           (if (minusp arg)
  1480.             (write-char #\- stream)
  1481.             (if atsign-modifier (write-char #\+ stream))
  1482.           )
  1483.           (if colon-modifier (format-padding padcount padchar stream))
  1484.           (format-padding (- lefts leadings) #\0 stream)
  1485.           (write-string digits stream)
  1486.       ) )
  1487.       (format-ascii-decimal arg stream)
  1488. ) ) )
  1489.  
  1490. ; ~%, CLTL S.397
  1491. (defun format-terpri (stream colon-modifier atsign-modifier &optional (count 1))
  1492.   (declare (ignore colon-modifier atsign-modifier))
  1493.   (if (null count) (setq count 1))
  1494.   (dotimes (i count) (terpri stream))
  1495. )
  1496.  
  1497. ; ~&, CLTL S.397
  1498. (defun format-fresh-line (stream colon-modifier atsign-modifier
  1499.                           &optional (count 1))
  1500.   (declare (ignore colon-modifier atsign-modifier))
  1501.   (if (null count) (setq count 1))
  1502.   (when (plusp count)
  1503.     (fresh-line stream)
  1504.     (dotimes (i (1- count)) (terpri stream))
  1505. ) )
  1506.  
  1507. ; ~|, CLTL S.397
  1508. (defun format-page (stream colon-modifier atsign-modifier &optional (count 1))
  1509.   (declare (ignore colon-modifier atsign-modifier))
  1510.   (if (null count) (setq count 1))
  1511.   (dotimes (i count) (write-char #\Page stream))
  1512. )
  1513.  
  1514. ; ~~, CLTL S.397
  1515. (defun format-tilde (stream colon-modifier atsign-modifier &optional (count 1))
  1516.   (declare (ignore colon-modifier atsign-modifier))
  1517.   (if (null count) (setq count 1))
  1518.   (dotimes (i count) (write-char #\~ stream))
  1519. )
  1520.  
  1521. ; ~T, CLTL S.398-399
  1522. (defun format-tabulate (stream colon-modifier atsign-modifier
  1523.                         &optional (colnum 1) (colinc 1))
  1524.   (declare (ignore colon-modifier))
  1525.   (if (null colnum) (setq colnum 1))
  1526.   (if (null colinc) (setq colinc 1))
  1527.   (let* ((new-colnum (max colnum 0))
  1528.          (new-colinc (max colinc 1)) ; >0
  1529.          (pos (sys::line-position stream))) ; aktuelle Position, Fixnum >=0
  1530.     (if atsign-modifier
  1531.       (format-padding
  1532.         (+ new-colnum (mod (- (+ pos new-colnum)) new-colinc))
  1533.         #\Space stream
  1534.       )
  1535.       (if (< pos new-colnum)
  1536.         (format-padding (- new-colnum pos) #\Space stream)
  1537.         (unless (zerop colinc)
  1538.           (format-padding (+ colinc (mod (- new-colnum pos) (- colinc)))
  1539.                           #\Space stream
  1540. ) ) ) ) ) )
  1541.  
  1542. ; ~*, CLTL S.399
  1543. (defun format-goto (stream colon-modifier atsign-modifier &optional (index nil))
  1544.   (declare (ignore stream))
  1545.   (if atsign-modifier
  1546.     (setq *FORMAT-NEXT-ARG* (nthcdr (or index 0) *FORMAT-ARG-LIST*))
  1547.     (format-goto-new-arg colon-modifier (or index 1))
  1548. ) )
  1549.  
  1550. ; ~?, CLTL S.399-401
  1551. (defun format-indirection (stream colon-modifier atsign-modifier)
  1552.   (declare (ignore colon-modifier))
  1553.   (let ((csarg (next-arg)))
  1554.     (unless (stringp csarg)
  1555.       (format-error *FORMAT-CS* nil
  1556.         #+DEUTSCH "Als Kontrollstring für ~~? ist das untauglich: ~S"
  1557.         #+ENGLISH "The control string argument for the ~~? directive is invalid: ~S"
  1558.         #+FRANCAIS "~S ne convient pas comme chaîne de contrôle pour ~~?."
  1559.         csarg
  1560.     ) )
  1561.     ; evtl. noch csarg zu einem Simple-String machen ??
  1562.     (let ((node (list csarg)))
  1563.       (format-parse-cs csarg 0 node nil)
  1564.       (if atsign-modifier
  1565.         (let ((*FORMAT-CS* (car node))
  1566.               (*FORMAT-CSDL* (cdr node))
  1567.               (*FORMAT-UP-AND-OUT* nil))
  1568.           (format-interpret stream)
  1569.         )
  1570.         (let ((arglistarg (next-arg)))
  1571.           (unless (listp arglistarg)
  1572.             (format-error *FORMAT-CS* nil
  1573.               #+DEUTSCH "Das ist keine passende Argumentliste für die ~~?-Direktive: ~S"
  1574.               #+ENGLISH "The argument list argument for the ~~? directive is invalid: ~S"
  1575.               #+FRANCAIS "Ceci n'est pas une liste d'arguments convenable pour la directive ~~? : ~S"
  1576.               arglistarg
  1577.           ) )
  1578.           (let* ((*FORMAT-CS* (car node))
  1579.                  (*FORMAT-CSDL* (cdr node))
  1580.                  (*FORMAT-ARG-LIST* arglistarg)
  1581.                  (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*))
  1582.             (format-interpret stream)
  1583. ) ) ) ) ) )
  1584.  
  1585. ; ~(, CLTL S.401
  1586. (defun format-case-conversion (stream colon-modifier atsign-modifier)
  1587.   (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1588.   (let ((tempstr
  1589.           (let ((tempstream (make-string-output-stream (sys::line-position stream))))
  1590.             (format-interpret tempstream 'FORMAT-CASE-CONVERSION-END)
  1591.             (get-output-stream-string tempstream)
  1592.        )) )
  1593.     (if colon-modifier
  1594.       (if atsign-modifier
  1595.         (write-string (nstring-upcase tempstr) stream)
  1596.         (write-string (nstring-capitalize tempstr) stream)
  1597.       )
  1598.       (if atsign-modifier
  1599.         (progn
  1600.           (setq tempstr (nstring-downcase tempstr))
  1601.           (dotimes (i (length tempstr)) ; erstes Zeichen zum Upcase machen
  1602.             (when (both-case-p (schar tempstr i))
  1603.               (setf (schar tempstr i) (char-upcase (schar tempstr i)))
  1604.               (return)
  1605.           ) )
  1606.           (write-string tempstr stream)
  1607.         )
  1608.         (write-string (nstring-downcase tempstr) stream)
  1609. ) ) ) )
  1610.  
  1611. ; ~[, CLTL S.402-403
  1612. (defun format-conditional (stream colon-modifier atsign-modifier
  1613.                            &optional (prefix nil))
  1614.   (if colon-modifier
  1615.     (if atsign-modifier
  1616.       (format-error *FORMAT-CS* nil
  1617.         #+DEUTSCH "~~[ geht nicht mit : und @ gleichzeitig."
  1618.         #+ENGLISH "The ~~[ directive cannot take both modifiers."
  1619.         #+FRANCAIS "La directive ~~[ ne peut pas accepter les deux qualificateurs : et @ en même temps."
  1620.       )
  1621.       (progn
  1622.         (when (next-arg)
  1623.           (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1624.         )
  1625.         (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1626.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1627.       )
  1628.     )
  1629.     (if atsign-modifier
  1630.       (when (next-arg)
  1631.         (format-goto-new-arg t 1)
  1632.         (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1633.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1634.       )
  1635.       (let ((index (or prefix (next-arg))))
  1636.         (unless (integerp index)
  1637.           (format-error *FORMAT-CS* nil
  1638.             #+DEUTSCH "Argument für ~~[ muß ein Integer sein, nicht ~S"
  1639.             #+ENGLISH "The ~~[ parameter must be an integer, not ~S"
  1640.             #+FRANCAIS "L'argument pour ~~[ doit être un entier et non ~S"
  1641.             index
  1642.         ) )
  1643.         (dotimes (i (if (minusp index) most-positive-fixnum index))
  1644.           (when (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
  1645.             (return)
  1646.           )
  1647.           (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1648.           (when (csd-colon-p (car *FORMAT-CSDL*)) (return))
  1649.         )
  1650.         (unless (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
  1651.           (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1652.         )
  1653.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1654.   ) ) )
  1655.   (format-skip-to-end) ; Weiterrücken bis ans Ende der ~[...~]-Direktive
  1656. )
  1657.  
  1658. ; ~{, CLTL S.403-404
  1659. (defun format-iteration (stream colon-modifier atsign-modifier
  1660.                          &optional (prefix nil))
  1661.   (let* ((total-csdl *FORMAT-CSDL*)
  1662.          (max-iteration-count prefix))
  1663.     (format-skip-to-end) ; Weiterrücken bis ans Ende der ~{...~}-Direktive
  1664.     (let* ((min-1-iteration (csd-colon-p (car *FORMAT-CSDL*)))
  1665.            (inner-cs (if (eq (cdr total-csdl) *FORMAT-CSDL*)
  1666.                        (next-arg)
  1667.                        *FORMAT-CS*
  1668.            )         )
  1669.            (inner-csdl (if (eq (cdr total-csdl) *FORMAT-CSDL*)
  1670.                          (let ((node (list inner-cs)))
  1671.                            (format-parse-cs inner-cs 0 node nil)
  1672.                            (cdr node)
  1673.                          )
  1674.                          (cdr total-csdl)
  1675.            )           )
  1676.            (arg-list-rest (if (not atsign-modifier)
  1677.                             (let ((arg (next-arg)))
  1678.                               (unless (listp arg)
  1679.                                 (format-error *FORMAT-CS* nil
  1680.                                   #+DEUTSCH "Das Argument zu ~~{ muß eine Liste sein, nicht ~S"
  1681.                                   #+ENGLISH "The ~~{ directive requires a list argument, not ~S"
  1682.                                   #+FRANCAIS "L'argument de ~~{ doit être une liste et non ~S"
  1683.                                   arg
  1684.                               ) )
  1685.                               arg
  1686.           ))              ) )
  1687.       (do* ((iteration-count 0 (1+ iteration-count)))
  1688.            ((or (and max-iteration-count
  1689.                      (>= iteration-count max-iteration-count)
  1690.                 )
  1691.                 (let ((remaining (if atsign-modifier
  1692.                                    *FORMAT-NEXT-ARG*
  1693.                                    arg-list-rest
  1694.                      ))          )
  1695.                   (if min-1-iteration
  1696.                     (and (plusp iteration-count) (null remaining))
  1697.                     (null remaining)
  1698.            ))   ) )
  1699.         (if colon-modifier
  1700.           (let* ((*FORMAT-ARG-LIST*
  1701.                    (if atsign-modifier (next-arg) (pop arg-list-rest))
  1702.                  )
  1703.                  (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
  1704.                  (*FORMAT-CS* inner-cs)
  1705.                  (*FORMAT-CSDL* inner-csdl)
  1706.                  (*FORMAT-UP-AND-OUT* nil))
  1707.             (format-interpret stream 'FORMAT-ITERATION-END)
  1708.             (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1709.           )
  1710.           (if atsign-modifier
  1711.             (let* ((*FORMAT-CS* inner-cs)
  1712.                    (*FORMAT-CSDL* inner-csdl)
  1713.                    (*FORMAT-UP-AND-OUT* nil))
  1714.               (format-interpret stream 'FORMAT-ITERATION-END)
  1715.               (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1716.             )
  1717.             (let* ((*FORMAT-ARG-LIST* arg-list-rest)
  1718.                    (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
  1719.                    (*FORMAT-CS* inner-cs)
  1720.                    (*FORMAT-CSDL* inner-csdl)
  1721.                    (*FORMAT-UP-AND-OUT* nil))
  1722.               (format-interpret stream 'FORMAT-ITERATION-END)
  1723.               (setq arg-list-rest *FORMAT-NEXT-ARG*)
  1724.               (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1725. ) ) ) ) ) ) )
  1726.  
  1727. ; ~<, CLTL S.404-406
  1728. (defun format-justification (stream colon-modifier atsign-modifier
  1729.        &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1730.   (if (null mincol) (setq mincol 0))
  1731.   (if (null colinc) (setq colinc 1))
  1732.   (if (null minpad) (setq minpad 0))
  1733.   (if (null padchar) (setq padchar #\Space))
  1734.   (let* ((saved-csdl *FORMAT-CSDL*)
  1735.          (pos (sys::line-position stream))
  1736.          (tempstream (make-string-output-stream pos))
  1737.          (check-on-line-overflow nil)
  1738.          supplementary-need
  1739.          line-length
  1740.          (old-piecelist
  1741.            (let ((pieces nil))
  1742.              (do ((first-piece-flag t nil))
  1743.                  ((eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-JUSTIFICATION-END))
  1744.                (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1745.                (let ((*FORMAT-UP-AND-OUT* nil))
  1746.                  (format-interpret tempstream 'FORMAT-JUSTIFICATION-END)
  1747.                  (when (and first-piece-flag (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-SEPARATOR))
  1748.                    (when (setq check-on-line-overflow (csd-colon-p (car *FORMAT-CSDL*)))
  1749.                      (multiple-value-setq (supplementary-need line-length)
  1750.                        (values-list (format-resolve-parms (car *FORMAT-CSDL*)))
  1751.                  ) ) )
  1752.                  (when *FORMAT-UP-AND-OUT*
  1753.                    (setq *FORMAT-CSDL* saved-csdl)
  1754.                    (format-skip-to-end)
  1755.                    (return)
  1756.                  )
  1757.                  (push (get-output-stream-string tempstream) pieces)
  1758.              ) )
  1759.              (nreverse pieces)
  1760.          ) )
  1761.          (piecelist
  1762.            (if check-on-line-overflow (cdr old-piecelist) old-piecelist)
  1763.         ))
  1764.     (if piecelist
  1765.       (multiple-value-bind (padblocklengths width)
  1766.         (format-justified-segments mincol colinc minpad
  1767.           colon-modifier atsign-modifier piecelist)
  1768.         (when (and check-on-line-overflow
  1769.                    (> (+ pos width (or supplementary-need 0))
  1770.                       (or line-length #|(sys::line-length stream)|# 72)
  1771.               )    )
  1772.           (write-string (first old-piecelist) stream)
  1773.         )
  1774.         (do ((i 0 (1+ i)))
  1775.             (nil)
  1776.           (when (svref padblocklengths i)
  1777.             (format-padding (svref padblocklengths i) padchar stream)
  1778.           )
  1779.           (when (null piecelist) (return))
  1780.           (write-string (pop piecelist) stream)
  1781.       ) )
  1782.       (format-padding mincol padchar stream)
  1783.     )
  1784. ) )
  1785.  
  1786. ; ~^, CLTL S.406-407
  1787. (defun format-up-and-out (stream colon-modifier atsign-modifier
  1788.                           &optional (a nil) (b nil) (c nil))
  1789.   (declare (ignore stream atsign-modifier))
  1790.   (if (cond ((and (null a) (null b) (null c)) ; keine Parameter
  1791.              (null *FORMAT-NEXT-ARG*)
  1792.             )
  1793.             ((and (null b) (null c)) (eql a 0)) ; ein Parameter
  1794.             ((null c) (eql a b)) ; zwei Parameter
  1795.             ((and (integerp a) (integerp b) (integerp c)) (<= a b c))
  1796.             ((and (characterp a) (characterp b) (characterp c)) (char<= a b c))
  1797.       )
  1798.     (setq *FORMAT-UP-AND-OUT* (if colon-modifier ':TERMINATE-ALL ':TERMINATE))
  1799. ) )
  1800.  
  1801. ;-------------------------------------------------------------------------------
  1802.  
  1803.